[!if FPCPRT != ""]
	Copyright (c) 2011-2012 by MicroStrategy, Inc.  This copyrighted material
	is the confidential, unpublished property of MicroStrategy.  This
	copyright notice and any other copyright notices included in machine
	readable copies must be reproduced on all authorized copies.
[!endif]
//=======================================================================
[!output COPYRIGHT_MSG]
//
//		File:	RSupport.cpp
//
//		Date:	[!output FPDATE]
//
//		Desc:	Implementation of CRSupport class.
//=======================================================================

//=======================================================================
// includes
//=======================================================================
#include "StdAfx.h"
#include "RSupport.h"

//=======================================================================
// constructor/destructor
//=======================================================================
CRSupport::CRSupport() :
	m_hinstLib(NULL),
	m_initR(0)
{
	InitR();
}

CRSupport::~CRSupport()
{
	EndR();
}

//=======================================================================
// methods
//=======================================================================
const Int32 KEY_BUFFER_SIZE = 1024;
STDMETHODIMP CRSupport::GetRInstallPath()
{
	CComBSTR		bstrKeyR						= L"SOFTWARE\\R-core\\R";
	CComBSTR		bstrValueInstallPath			= L"InstallPath";
	HKEY			hKey;
	DWORD			retCode;
	DWORD			dwValType;
	DWORD			dwSize							= KEY_BUFFER_SIZE;
	wchar_t			sKeyValue[KEY_BUFFER_SIZE];
	HRESULT			hr								= S_OK;

	try
	{
		// open R installation key
		if(RegOpenKeyEx(HKEY_LOCAL_MACHINE, bstrKeyR, 0, KEY_READ, &hKey))
			// key not found
			throw E_FAIL;

		// fetch the InstallPath value
		if(!(retCode=RegQueryValueEx(hKey, bstrValueInstallPath, 0, &dwValType, (BYTE *)&sKeyValue,
			&dwSize)))
		{
			// found it...validate its type
			if(dwValType==REG_SZ)
			{
				// expected type...save R install path
				m_sRInstallPath = sKeyValue;
				if(!m_sRInstallPath)
					throw E_OUTOFMEMORY;
			}
			else
				// unexpected type
				throw E_FAIL;
		}
		else
			// key value not found
			throw E_FAIL;
	}
	catch(HRESULT catchHR)
	{
		hr = catchHR;
	}
	catch(...)
	{
		hr = E_FAIL;
	}

	return hr;
}

Int_32 CRSupport::InitR()
{
	char		*localArgs[]	= {"R", "--silent"};
	CComBSTR	sDllDirectory;
	HRESULT		hr				= S_OK;

	if(m_hinstLib==NULL)
	{
		// get a handle to the DLL module (search <R install root>\bin\i386 first)
		hr = GetRInstallPath();
		if FAILED(hr) return 1;
		sDllDirectory = m_sRInstallPath;
		sDllDirectory.Append(L"\\bin\\i386");
		if(!SetDllDirectory(sDllDirectory))
			// error
			return 1;
		m_hinstLib = LoadLibrary(TEXT("R.dll"));
		if(!m_hinstLib)
		{
			// DLL not found...try <R install path>\bin
			sDllDirectory = m_sRInstallPath;
			sDllDirectory.Append(L"\\bin");
			if(!SetDllDirectory(sDllDirectory))
				// error
				return 1;
			m_hinstLib = LoadLibrary(TEXT("R.dll"));
		}
	}
	else
		// handle already exists
		return 0;
 
	// check if handle is valid
    if(m_hinstLib != NULL) 
    {
		// valid handle...fetch function addresses
		m_R_GlobalEnv_win = (SEXP *)GetProcAddress(m_hinstLib, "R_GlobalEnv");
		m_R_UnboundValue_win = (SEXP *)GetProcAddress(m_hinstLib, "R_UnboundValue");
		m_Rf_initEmbeddedR_win = (pRf_initEmbeddedR)GetProcAddress(m_hinstLib, "Rf_initEmbeddedR");
		m_Rf_protect_win = (pRf_protect)GetProcAddress(m_hinstLib, "Rf_protect");
		m_lang2_win = (pRf_lang2)GetProcAddress(m_hinstLib, "Rf_lang2");
		m_install_win = (pRf_install)GetProcAddress(m_hinstLib, "Rf_install");
		m_mkChar_win = (pRf_mkChar)GetProcAddress(m_hinstLib, "Rf_mkChar");
		m_mkString_win = (pRf_mkString)GetProcAddress(m_hinstLib, "Rf_mkString");
		m_R_tryEval_win = (pR_tryEval)GetProcAddress(m_hinstLib, "R_tryEval");
		m_Rf_unprotect_win = (pRf_unprotect)GetProcAddress(m_hinstLib, "Rf_unprotect");
		m_Rf_PrintValue_win = (pRf_PrintValue)GetProcAddress(m_hinstLib, "Rf_PrintValue");
		m_Rf_endEmbeddedR_win = (pRf_endEmbeddedR)GetProcAddress(m_hinstLib, "Rf_endEmbeddedR");
		m_Rf_allocVector_win = (pRf_allocVector)GetProcAddress(m_hinstLib, "Rf_allocVector");
		m_Rf_allocMatrix_win = (pRf_allocMatrix)GetProcAddress(m_hinstLib, "Rf_allocMatrix");
		m_REAL_win = (p_REAL)GetProcAddress(m_hinstLib, "REAL");
		m_INTEGER_win = (p_INTEGER)GetProcAddress(m_hinstLib, "INTEGER");
		m_LOGICAL_win = (p_INTEGER)GetProcAddress(m_hinstLib, "LOGICAL");
		m_defineVar_win = (pRf_defineVar)GetProcAddress(m_hinstLib, "Rf_defineVar");
		m_asReal_win = (pRf_asReal)GetProcAddress(m_hinstLib, "Rf_asReal");
		m_ScalarInteger_win = (pRf_ScalarInteger)GetProcAddress(m_hinstLib, "Rf_ScalarInteger");
		m_length_win = (pRf_length)GetProcAddress(m_hinstLib, "Rf_length");
		m_TYPEOF_win = (p_TYPEOF)GetProcAddress(m_hinstLib, "TYPEOF");
		m_findVar_win = (pRf_findVar)GetProcAddress(m_hinstLib, "Rf_findVar");
		m_eval_win = (pRf_eval)GetProcAddress(m_hinstLib, "Rf_eval");
		m_SET_STRING_ELT_win = (p_SET_STRING_ELT)GetProcAddress(m_hinstLib, "SET_STRING_ELT");
		m_STRING_ELT_win = (p_STRING_ELT)GetProcAddress(m_hinstLib, "STRING_ELT");
		m_translateChar_win = (pRf_translateChar)GetProcAddress(m_hinstLib, "Rf_translateChar");
		m_R_finite_win = (pR_finite)GetProcAddress(m_hinstLib, "R_finite");
		m_pNaReal_win = (double *)GetProcAddress(m_hinstLib, "R_NaReal");
		m_pNaInteger_win = (int *)GetProcAddress(m_hinstLib, "R_NaInt");
		m_pNaLogical_win = (int *)GetProcAddress(m_hinstLib, "R_NaInt");
		m_pNaString_win = (SEXP *)GetProcAddress(m_hinstLib, "R_NaString");

		if(m_Rf_initEmbeddedR_win && m_Rf_protect_win && m_lang2_win && m_install_win && m_mkChar_win && m_mkString_win &&
			m_R_tryEval_win && m_Rf_unprotect_win && m_Rf_PrintValue_win && m_Rf_endEmbeddedR_win && m_Rf_allocVector_win &&
			m_Rf_allocMatrix_win && m_REAL_win && m_INTEGER_win && m_LOGICAL_win && m_defineVar_win && m_asReal_win &&
			m_ScalarInteger_win && m_length_win && m_TYPEOF_win && m_findVar_win && m_eval_win && m_R_GlobalEnv_win &&
			m_R_UnboundValue_win && m_SET_STRING_ELT_win && m_STRING_ELT_win && m_translateChar_win && m_R_finite_win &&
			m_pNaReal_win && m_pNaInteger_win && m_pNaLogical_win && m_pNaString_win)
		{
			m_initR = m_Rf_initEmbeddedR_win(sizeof(localArgs) / sizeof(localArgs[0]), localArgs);
			if(!m_initR)
				// error
				return 1;

			// success
			return 0;
		}
	}

	// error
	return 1;
}

void CRSupport::EndR()
{
	if(m_initR)
		m_Rf_endEmbeddedR_win(0);

	if(m_hinstLib)
	{
		// free the DLL module
        FreeLibrary(m_hinstLib);
		m_hinstLib=NULL;
    }
}

// handles numeric, scalar/vector, non-repeated inputs for SIM, GEN & AGG FPs
void CRSupport::SetRVar(
	const char *pName,
	Int_32 nSize,
	double *pData,
	DSSData_Flags *pFlag)
{
	SEXP	pRVector;
	double	*pRValues;
	bool	bValid;

	// allocate vector of REAL in R
	m_Rf_protect_win(pRVector = m_Rf_allocVector_win(REALSXP, nSize));
	pRValues = m_REAL_win(pRVector);

	// initialize vector with input data
	for(Int_32 i=0;i<nSize;i++)
	{
		// check for valid input
		bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
		if(bValid)
			// initialize value with input data
			*(pRValues+i) = pData[i];
		else // missing...set to NA
			*(pRValues+i) = *m_pNaReal_win;
	}

	// define variable
	m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
	m_Rf_unprotect_win(1);
}

// handles numeric, scalar, repeated inputs for SIM FPs
void CRSupport::SetRVar_rp(
	const char *pName,
	Int_32 nSize,
	Int_32 lPIndex,
	Int_32 lRepCnt,
	double *pData,
	DSSData_Flags *pFlag)
{
	SEXP	pRVector;
	double	*pRValues;
	bool	bValid;
	Int_32	lSkipIndex;

	// allocate vector of REAL in R
	m_Rf_protect_win(pRVector = m_Rf_allocVector_win(REALSXP, nSize / lRepCnt));
	pRValues = m_REAL_win(pRVector);

	// initialize vector with input data
	lSkipIndex = lPIndex - 1;
	Int_32 j = 0;
	for(Int_32 i=0;i<nSize;i++)
	{
		lSkipIndex++;
		if(lSkipIndex % lRepCnt)
			continue;

		// check for valid input
		bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
		if(bValid)
			// initialize value with input data
			*(pRValues+j) = pData[i];
		else // missing...set to NA
			*(pRValues+j) = *m_pNaReal_win;
		j++;
	}

	// define variable
	m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
	m_Rf_unprotect_win(1);
}

// handles numeric, scalar/vector, repeated inputs for GEN FPs
STDMETHODIMP CRSupport::SetRVar_mx(
	const char *pName,
	Int_32 lPIndex,
	Int_32 nRows,
	Int_32 nCols,
	double *pData,
	DSSData_Flags *pFlag)
{
	SEXP		pRMatrix;
	double		*pRValues;
	bool		bValid;
	HRESULT		hr			= S_OK;

	try
	{
		if(lPIndex==0)
			// allocate matrix of REAL in R
			m_Rf_protect_win(pRMatrix = m_Rf_allocMatrix_win(REALSXP, nRows, nCols));
		else
		{
			// find previously allocated matix
			m_Rf_protect_win(pRMatrix=m_findVar_win(m_install_win(pName), *m_R_GlobalEnv_win));
			if(pRMatrix==*m_R_UnboundValue_win)
				// variable not found in R environment
				throw E_FAIL;
		}
		pRValues = m_REAL_win(pRMatrix);

		// initialize specified column of matrix with input data
		for(Int_32 i=0,j=lPIndex*nRows;i<nRows;i++,j++)
		{
			// check for valid input
			bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
			if(bValid)
				// initialize value with input data
				*(pRValues+j) = pData[i];
			else // missing...set to NA
				*(pRValues+j) = *m_pNaReal_win;
		}

		if(lPIndex==0)
			// define variable
			m_defineVar_win(m_install_win(pName), pRMatrix, *m_R_GlobalEnv_win);
		m_Rf_unprotect_win(1);
	}
	catch(HRESULT catchHR)
	{
		hr = catchHR;
	}
	catch(...)
	{
		hr = E_FAIL;
	}

	return hr;
}

// handles variant properties for all FPs, and variant, scalar, non-repeated inputs for NNSIM and NNGEN FPs
STDMETHODIMP CRSupport::SetRVarV(
	const char *pName,
	VARIANT *pValue,
	DSSData_Flags *pFlag)
{
	SEXP		pRVector;
	double		*pRValue;
	bool		bValid;
	HRESULT		hr			= S_OK;

	try
	{
		switch(pValue->vt)
		{
		case VT_R8:
		case VT_R4:
		case VT_I4:
		case VT_I2:
		case VT_UI1:
			{
				// allocate vector of REAL in R
				m_Rf_protect_win(pRVector = m_Rf_allocVector_win(REALSXP, 1));
				pRValue = m_REAL_win(pRVector);

				// check for valid input
				bValid = pFlag ? (*pFlag==DssDataOk) : true;
				if(bValid)
				{
					// change to VT_R8
					hr = VariantChangeType(pValue, pValue, 0, VT_R8);
					if(FAILED(hr)) throw hr;

					// initialize value with input data
					*pRValue = pValue->dblVal;
				}
				else // DssDataNull...set to NA
					*pRValue = *m_pNaReal_win;

				// define variable
				m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
				m_Rf_unprotect_win(1);

				break;
			}
		case VT_BOOL:
			{
				// allocate vector of REAL in R
				m_Rf_protect_win(pRVector = m_Rf_allocVector_win(REALSXP, 1));
				pRValue = m_REAL_win(pRVector);

				// check for valid input
				bValid = pFlag ? (*pFlag==DssDataOk) : true;
				if(bValid)
					// convert boolean to 0 (false) or 1 (true)
					*pRValue = (pValue->boolVal==VARIANT_TRUE) ? 1 : 0;
				else // DssDataNull...set to NA
					*pRValue = *m_pNaReal_win;

				// define variable
				m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
				m_Rf_unprotect_win(1);

				break;
			}
		case VT_BSTR:
			{
				// allocate vector of string in R
				m_Rf_protect_win(pRVector = m_Rf_allocVector_win(STRSXP, 1));

				// check for valid input
				bValid = pFlag ? (*pFlag==DssDataOk) : true;
				if(bValid)
				{
					// convert variant string to char *
					Int_32 lSrcLen = SysStringLen(pValue->bstrVal);
					char *pStrVal = new char [lSrcLen + 1];
					if(!pStrVal) throw E_OUTOFMEMORY;
					size_t returnLen;
					wcstombs_s(&returnLen, pStrVal, lSrcLen+1, pValue->bstrVal, lSrcLen);

					// initialize value with input data
					m_SET_STRING_ELT_win(pRVector, 0, m_mkChar_win(pStrVal));
					delete [] pStrVal;
				}
				else // missing...set to NA
					m_SET_STRING_ELT_win(pRVector, 0, *m_pNaString_win);

				// define variable
				m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
				m_Rf_unprotect_win(1);

				break;
			}
		default:
			{
				// unexpected data type
				throw E_FAIL;
			}
		}
	}
	catch(HRESULT catchHR)
	{
		hr = catchHR;
	}
	catch(...)
	{
		hr = E_FAIL;
	}

	return hr;
}

// handles variant, vector, non-repeated inputs for NNGEN FPs
STDMETHODIMP CRSupport::SetRVarSA(
	const char *pName,
	Int_32 nSize,
	EnumDSSDataType dataType,
	VARIANT *pData,
	DSSData_Flags *pFlag)
{
	SEXP		pRVector;
	VARIANT		varElem;
	bool		bValid;
	HRESULT		hr			= S_OK;

	try
	{
		// initialize
		VariantInit(&varElem);

		// check data type
		switch(dataType)
		{
		case DssDataTypeDouble:
			{
				double *pRValues;

				// allocate vector of REAL in R
				m_Rf_protect_win(pRVector = m_Rf_allocVector_win(REALSXP, nSize));
				pRValues = m_REAL_win(pRVector);

				// initialize vector with input data
				for(Int_32 i=0;i<nSize;i++)
				{
					// check for valid input
					bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
					if(bValid)
					{
						// fetch element and convert to double
						SafeArrayGetElement(pData->parray, (LONG *)&i, &varElem);
						hr = VariantChangeType(&varElem, &varElem, 0, VT_R8);
						if(FAILED(hr)) throw hr;

						// initialize value with input data
						*(pRValues+i) = varElem.dblVal;
						VariantClear(&varElem);
					}
					else // missing...set to NA
						*(pRValues+i) = *m_pNaReal_win;
				}

				// define variable
				m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
				m_Rf_unprotect_win(1);

				break;
			}
		case DssDataTypeVarChar:
			{
				Int_32 lSrcLen;
				CHSTR strVal;
				size_t returnLen;

				// allocate vector of string in R
				m_Rf_protect_win(pRVector = m_Rf_allocVector_win(STRSXP, nSize));

				// initialize vector with input data
				for(Int_32 i=0;i<nSize;i++)
				{
					// check for valid input
					bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
					if(bValid)
					{
						// fetch element and convert to CHSTR
						SafeArrayGetElement(pData->parray, (LONG *)&i, &varElem);
						hr = VariantChangeType(&varElem, &varElem, 0, VT_BSTR);
						if(FAILED(hr)) throw hr;
						lSrcLen = SysStringLen(varElem.bstrVal);
						wcstombs_s(&returnLen, strVal, MAXSIZE_CHAR_STR, varElem.bstrVal, lSrcLen);

						// initialize value with input data
						m_SET_STRING_ELT_win(pRVector, i, m_mkChar_win(strVal));
						VariantClear(&varElem);
					}
					else // missing...set to NA
						m_SET_STRING_ELT_win(pRVector, i, *m_pNaString_win);
				}

				// define variable
				m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
				m_Rf_unprotect_win(1);

				break;
			}
		default:
			{
				// unexpected data type
				throw E_FAIL;
			}
		}
	}
	catch(HRESULT catchHR)
	{
		hr = catchHR;
	}
	catch(...)
	{
		hr = E_FAIL;
	}

	return hr;
}

// handles variant, scalar, repeated inputs for NNSIM FPs
STDMETHODIMP CRSupport::SetRVarSA_rp(
	const char *pName,
	Int_32 nSize,
	Int_32 lPIndex,
	Int_32 lInCnt,
	Int_32 lRepCnt,
	EnumDSSDataType dataType,
	VARIANT *pData,
	DSSData_Flags *pFlag)
{
	SEXP		pRVector;
	VARIANT		varElem;
	bool		bValid;
	Int_32		lSkipIndex;
	Int_32		lNonRepeatCnt;
	Int_32		lRepeatSize;
	HRESULT		hr				= S_OK;

	try
	{
		// initialize
		VariantInit(&varElem);
		lNonRepeatCnt = lInCnt - lRepCnt;
		lRepeatSize = (nSize - lNonRepeatCnt) / lRepCnt;

		// check data type
		switch(dataType)
		{
		case DssDataTypeDouble:
			{
				double *pRValues;

				// allocate vector of REAL in R
				m_Rf_protect_win(pRVector = m_Rf_allocVector_win(REALSXP, lRepeatSize));
				pRValues = m_REAL_win(pRVector);

				// initialize vector with input data
				lSkipIndex = lPIndex - 1;
				Int_32 j = 0;
				for(Int_32 i=lNonRepeatCnt;i<nSize;i++)
				{
					lSkipIndex++;
					if(lSkipIndex % lRepCnt)
						continue;

					// check for valid input
					bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
					if(bValid)
					{
						// fetch element and convert to double
						SafeArrayGetElement(pData->parray, (LONG *)&i, &varElem);
						hr = VariantChangeType(&varElem, &varElem, 0, VT_R8);
						if(FAILED(hr)) throw hr;

						// initialize value with input data
						*(pRValues+j) = varElem.dblVal;
						VariantClear(&varElem);
					}
					else // missing...set to NA
						*(pRValues+j) = *m_pNaReal_win;
					j++;
				}

				// define variable
				m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
				m_Rf_unprotect_win(1);

				break;
			}
		case DssDataTypeVarChar:
			{
				Int_32 lSrcLen;
				CHSTR strVal;
				size_t returnLen;

				// allocate vector of string in R
				m_Rf_protect_win(pRVector = m_Rf_allocVector_win(STRSXP, lRepeatSize));

				// initialize vector with input data
				lSkipIndex = lPIndex - 1;
				Int_32 j = 0;
				for(Int_32 i=lNonRepeatCnt;i<nSize;i++)
				{
					lSkipIndex++;
					if(lSkipIndex % lRepCnt)
						continue;

					// check for valid input
					bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
					if(bValid)
					{
						// fetch element and convert to CHSTR
						SafeArrayGetElement(pData->parray, (LONG *)&i, &varElem);
						hr = VariantChangeType(&varElem, &varElem, 0, VT_BSTR);
						if(FAILED(hr)) throw hr;
						lSrcLen = SysStringLen(varElem.bstrVal);
						wcstombs_s(&returnLen, strVal, MAXSIZE_CHAR_STR, varElem.bstrVal, lSrcLen);

						// initialize value with input data
						m_SET_STRING_ELT_win(pRVector, j, m_mkChar_win(strVal));
						VariantClear(&varElem);
					}
					else // missing...set to NA
						m_SET_STRING_ELT_win(pRVector, j, *m_pNaString_win);
					j++;
				}

				// define variable
				m_defineVar_win(m_install_win(pName), pRVector, *m_R_GlobalEnv_win);
				m_Rf_unprotect_win(1);

				break;
			}
		default:
			{
				// unexpected data type
				throw E_FAIL;
			}
		}
	}
	catch(HRESULT catchHR)
	{
		hr = catchHR;
	}
	catch(...)
	{
		hr = E_FAIL;
	}

	return hr;
}

// handles variant, scalar/vector, repeated inputs for NNGEN FPs
STDMETHODIMP CRSupport::SetRVarSA_mx(
	const char *pName,
	Int_32 lPIndex,
	Int_32 nRows,
	Int_32 nCols,
	EnumDSSDataType dataType,
	VARIANT *pData,
	DSSData_Flags *pFlag)
{
	SEXP		pRMatrix;
	VARIANT		varElem;
	bool		bValid;
	HRESULT		hr			= S_OK;

	try
	{
		// initialize
		VariantInit(&varElem);

		// check data type
		switch(dataType)
		{
		case DssDataTypeDouble:
			{
				double *pRValues;

				if(lPIndex==0)
					// allocate matrix of REAL in R
					m_Rf_protect_win(pRMatrix = m_Rf_allocMatrix_win(REALSXP, nRows, nCols));
				else
				{
					// find previously allocated matix
					m_Rf_protect_win(pRMatrix=m_findVar_win(m_install_win(pName), *m_R_GlobalEnv_win));
					if(pRMatrix==*m_R_UnboundValue_win)
						// variable not found in R environment
						throw E_FAIL;
				}

				// initialize specified column of matrix with input data
				pRValues = m_REAL_win(pRMatrix);
				for(Int_32 i=0,j=lPIndex*nRows;i<nRows;i++,j++)
				{
					// check for valid input
					bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
					if(bValid)
					{
						// fetch element and convert to double
						SafeArrayGetElement(pData->parray, (LONG *)&i, &varElem);
						hr = VariantChangeType(&varElem, &varElem, 0, VT_R8);
						if(FAILED(hr)) throw hr;

						// initialize value with input data
						*(pRValues+j) = varElem.dblVal;
						VariantClear(&varElem);
					}
					else // missing...set to NA
						*(pRValues+j) = *m_pNaReal_win;
				}

				break;
			}
		case DssDataTypeVarChar:
			{
				Int_32 lSrcLen;
				CHSTR strVal;
				size_t returnLen;

				if(lPIndex==0)
					// allocate matrix of strings in R
					m_Rf_protect_win(pRMatrix = m_Rf_allocMatrix_win(STRSXP, nRows, nCols));
				else
				{
					// find previously allocated matrix
					m_Rf_protect_win(pRMatrix=m_findVar_win(m_install_win(pName), *m_R_GlobalEnv_win));
					if(pRMatrix==*m_R_UnboundValue_win)
						// variable not found in R environment
						throw E_FAIL;
				}

				// initialize specified column of matrix with input data
				for(Int_32 i=0,j=lPIndex*nRows;i<nRows;i++,j++)
				{
					// check for valid input
					bValid = pFlag ? (pFlag[i]==DssDataOk) : true;
					if(bValid)
					{
						// fetch element and convert to CHSTR
						SafeArrayGetElement(pData->parray, (LONG *)&i, &varElem);
						hr = VariantChangeType(&varElem, &varElem, 0, VT_BSTR);
						if(FAILED(hr)) throw hr;
						lSrcLen = SysStringLen(varElem.bstrVal);
						wcstombs_s(&returnLen, strVal, MAXSIZE_CHAR_STR, varElem.bstrVal, lSrcLen);

						// initialize value with input data
						m_SET_STRING_ELT_win(pRMatrix, j, m_mkChar_win(strVal));
						VariantClear(&varElem);
					}
					else // missing...set to NA
						m_SET_STRING_ELT_win(pRMatrix, j, *m_pNaString_win);
				}

				break;
			}
		default:
			{
				// unexpected data type
				throw E_FAIL;
			}
		}

		if(lPIndex==0)
			// define variable
			m_defineVar_win(m_install_win(pName), pRMatrix, *m_R_GlobalEnv_win);
		m_Rf_unprotect_win(1);
	}
	catch(HRESULT catchHR)
	{
		hr = catchHR;
	}
	catch(...)
	{
		hr = E_FAIL;
	}

	return hr;
}

Int_32 CRSupport::SubmitR(
	const char *script)
{
	SEXP	e;
	int		lErrorCode;

	m_Rf_protect_win(e=m_lang2_win(m_install_win("source"), m_mkString_win(script)));
	m_R_tryEval_win(e, *m_R_GlobalEnv_win, &lErrorCode);
	m_Rf_unprotect_win(1);

	return lErrorCode;
}

void CRSupport::GetRVar(
	const char *pName,
	Int_32 nSize,
	Int_32 *pRSize,
	double *pResult,
	DSSData_Flags *pFlag)
{
	SEXP	s;
	Int_32	lSize	= 0;

	m_Rf_protect_win(s=m_findVar_win(m_install_win(pName), *m_R_GlobalEnv_win));
	if(s==*m_R_UnboundValue_win)
		// variable not found in R environment
		*pRSize = 0;	
	else
	{
		// fetch length of results
		*pRSize = m_length_win(s);

		// determine size of results to be copied (do not exceed expected size)
		lSize = (*pRSize > nSize) ? nSize : *pRSize;

		// access results based on data type
		switch(m_TYPEOF_win(s))
		{
		case REALSXP:
			{
				double dblTemp;
				double *pREAL = m_REAL_win(s);
				for(Int_32 i=0;i<lSize;i++)
				{
					pFlag[i] = DssDataInvalid;
					dblTemp = pREAL[i];

					// TODO: add your post-processing code here

					if(m_R_finite_win(dblTemp))
					{
						pResult[i] = dblTemp;
						pFlag[i] = DssDataOk;
					}
					//else...result is invalid...flag already set to invalid
				}
				break;
			}
		case INTSXP:
			{
				int iTemp;
				int *pINTEGER = m_INTEGER_win(s);
				for(Int_32 i=0;i<lSize;i++)
				{
					pFlag[i] = DssDataInvalid;
					iTemp = pINTEGER[i];

					// TODO: add your post-processing code here

					if(iTemp!=*m_pNaInteger_win)
					{
						pResult[i] = (double)iTemp;
						pFlag[i] = DssDataOk;
					}
					//else...result is invalid...flag already set to invalid
				}
				break;
			}
		case LGLSXP:
			{
				int iTemp;
				int *pLOGICAL = m_LOGICAL_win(s);
				for(Int_32 i=0;i<lSize;i++)
				{
					pFlag[i] = DssDataInvalid;
					iTemp = pLOGICAL[i];

					// TODO: add your post-processing code here

					if(iTemp!=*m_pNaLogical_win)
					{
						pResult[i] = (double)iTemp;
						pFlag[i] = DssDataOk;
					}
					//else...result is invalid...flag already set to invalid
				}
				break;
			}
		default:
			{
				// unsupported data type
				*pRSize = 0;

				// setting lSize to zero will result in all flags being set to invalid
				lSize = 0;
			}
		}
	}

	// if fewer results returned than expected (i.e. lSize < nSize), set remaining flags to invalid
	for(Int_32 i=lSize;i<nSize;i++)
		pFlag[i] = DssDataInvalid;

	m_Rf_unprotect_win(1);
}
[!if FUNCPACKAGE_NONNUMERIC]

STDMETHODIMP CRSupport::GetRVarNN(
	const char *pName,
	Int_32 nStrLen,
	Int_32 nSize,
	Int_32 *pRSize,
	VARIANT *pResult,
	DSSData_Flags *pFlag)
{
	char		*sTemp	= NULL;
	SEXP		s;
	Int_32		lSize	= 0;
	VARIANT		output;
	HRESULT		hr		= S_OK;

	USES_CONVERSION;

	try
	{
		// initialize
		VariantInit(&output);

		m_Rf_protect_win(s=m_findVar_win(m_install_win(pName), *m_R_GlobalEnv_win));
		if(s==*m_R_UnboundValue_win)
			// variable not found in R environment
			*pRSize = 0;	
		else
		{
			// fetch length of results
			*pRSize = m_length_win(s);

			// determine size of results to be copied (do not exceed expected size)
			lSize = (*pRSize > nSize) ? nSize : *pRSize;

			// access results based on data type
			switch(m_TYPEOF_win(s))
			{
			case REALSXP:
				{
					double dblTemp;
					double *pREAL = m_REAL_win(s);

					if(pResult->vt==VT_R8)
					{
						// scalar output...init flag
						*pFlag = DssDataInvalid;

						// verify size
						if(lSize > 0)
						{
							// output available...fetch first result
							dblTemp = pREAL[0];

							// TODO: add your post-processing code here

							// return single result and set flag
							if(m_R_finite_win(dblTemp))
							{
								pResult->dblVal = dblTemp;
								*pFlag = DssDataOk;
							}
							//else...result is invalid...flag already set to invalid
						}
						//else...unexpected size...NULL would return size=0...flag already set to invalid
					}
					else if(pResult->vt==VT_BSTR)
						// unexpected type...set flag to invalid
						*pFlag = DssDataInvalid;
					else
					{
						// vector output...copy results to safe array
						for(Int_32 i=0;i<lSize;i++)
						{
							// init flag and fetch result
							pFlag[i] = DssDataInvalid;
							dblTemp = pREAL[i];

							// TODO: add your post-processing code here

							if(m_R_finite_win(dblTemp))
							{
								output.vt = VT_R8;
								output.dblVal = dblTemp;

								// save to safe array
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
								VariantClear(&output);
								pFlag[i] = DssDataOk;
							}
							else
								// result is invalid...flag already set to invalid...save empty value to safe array
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
						}
					}

					break;
				}
			case INTSXP:
				{
					int iTemp;
					int *pINTEGER = m_INTEGER_win(s);

					if(pResult->vt==VT_R8)
					{
						// scalar output...init flag
						*pFlag = DssDataInvalid;

						// verify size
						if(lSize > 0)
						{
							// output available...fetch first result
							iTemp = pINTEGER[0];

							// TODO: add your post-processing code here

							// return single result and set flag
							if(iTemp!=*m_pNaInteger_win)
							{
								pResult->dblVal = (double)iTemp;
								*pFlag = DssDataOk;
							}
							//else...result is invalid...flag already set to invalid
						}
						//else...unexpected size...NULL would return size=0...flag already set to invalid
					}
					else if(pResult->vt==VT_BSTR)
						// unexpected type...set flag to invalid
						*pFlag = DssDataInvalid;
					else
					{
						// vector output...copy results to safe array
						for(Int_32 i=0;i<lSize;i++)
						{
							// init flag and fetch result
							pFlag[i] = DssDataInvalid;
							iTemp = pINTEGER[i];

							// TODO: add your post-processing code here

							if(iTemp!=*m_pNaInteger_win)
							{
								output.vt = VT_R8;
								output.dblVal = (double)iTemp;

								// save to safe array and set flag
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
								VariantClear(&output);
								pFlag[i] = DssDataOk;
							}
							else
								// result is invalid...flag already set to invalid...save empty value to safe array
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
						}
					}

					break;
				}
			case LGLSXP:
				{
					int iTemp;
					int *pLOGICAL = m_LOGICAL_win(s);

					if(pResult->vt==VT_R8)
					{
						// scalar output...init flag
						*pFlag = DssDataInvalid;

						// verify size
						if(lSize > 0)
						{
							// output available...fetch first result
							iTemp = pLOGICAL[0];

							// TODO: add your post-processing code here

							// return single result and set flag
							if(iTemp!=*m_pNaLogical_win)
							{
								pResult->dblVal = (double)iTemp;
								*pFlag = DssDataOk;
							}
							//else...result is invalid...flag already set to invalid
						}
						//else...unexpected size...NULL would return size=0...flag already set to invalid
					}
					else if(pResult->vt==VT_BSTR)
						// unexpected type...set flag to invalid
						*pFlag = DssDataInvalid;
					else
					{
						// vector output...copy results to safe array
						for(Int_32 i=0;i<lSize;i++)
						{
							// init flag and fetch result
							pFlag[i] = DssDataInvalid;
							iTemp = pLOGICAL[i];

							// TODO: add your post-processing code here

							if(iTemp!=*m_pNaLogical_win)
							{
								output.vt = VT_R8;
								output.dblVal = (double)iTemp;

								// save to safe array and set flag
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
								VariantClear(&output);
								pFlag[i] = DssDataOk;
							}
							else
								// result is invalid...flag already set to invalid...save empty value to safe array
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
						}
					}

					break;
				}
			case STRSXP:
				{
					SEXP strElem;

					// allocate temp buffer
					sTemp = new char[nStrLen];
					if(!sTemp)
						throw E_OUTOFMEMORY;

					if(pResult->vt==VT_BSTR)
					{
						// scalar output...init flag
						*pFlag = DssDataInvalid;

						// verify size
						if(lSize > 0)
						{
							// output available...fetch first result
							strElem = m_STRING_ELT_win(s, 0);

							// check if NA
							if(strElem != *m_pNaString_win)
							{
								// translate to char *
								strcpy_s(sTemp, nStrLen, m_translateChar_win(strElem));

								// TODO: add your post-processing code here

								// return single string and set flag
								pResult->bstrVal = SysAllocString(A2W(sTemp));
								if(!pResult->bstrVal)
									throw E_OUTOFMEMORY;
								*pFlag = DssDataOk;
							}
							//else...string is NA...flag already set to invalid
						}
						//else...unexpected size...NULL would return size=0...flag already set to invalid
					}
					else if(pResult->vt==VT_R8)
						// unexpected type...set flag to invalid
						*pFlag = DssDataInvalid;
					else
					{
						// vector output...copy results to safe array
						for(Int_32 i=0;i<lSize;i++)
						{
							// init flag and fetch result
							pFlag[i] = DssDataInvalid;
							strElem = m_STRING_ELT_win(s, i);

							// check if NA
							if(strElem != *m_pNaString_win)
							{
								strcpy_s(sTemp, MAXSIZE_CHAR_STR, m_translateChar_win(strElem));

								// TODO: add your post-processing code here

								// convert to wide char
								output.vt = VT_BSTR;
								output.bstrVal = SysAllocString(A2W(sTemp));
								if(!output.bstrVal)
									throw E_OUTOFMEMORY;

								// save to safe array and set flag
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
								VariantClear(&output);
								pFlag[i] = DssDataOk;
							}
							else
								// element is NA...flag already set to invalid...save empty value to safe array
								hr=SafeArrayPutElement(pResult->parray, (LONG *)&i, &output);
						}
					}

					break;
				}
			default:
				{
					// unsupported data type
					*pRSize = 0;

					// setting lSize to zero will result in all flags being set to invalid
					lSize = 0;
				}
			}
		}

		// if fewer results returned than expected (i.e. lSize < nSize), set remaining flags to invalid
		for(Int_32 i=lSize;i<nSize;i++)
			pFlag[i] = DssDataInvalid;

		m_Rf_unprotect_win(1);
	}
	catch(HRESULT catchHR)
	{
		hr = catchHR;
	}
	catch(...)
	{
		hr = E_FAIL;
	}

	// clean up
	delete [] sTemp;

	return hr;
}
[!endif]
